home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / tclmotif.1 / tclmotif / tm.1.2 / send / tclXtSend.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-03-01  |  33.8 KB  |  1,255 lines
  1. /* 
  2.  * tmSend.c --
  3.  *
  4.  *    This file provides procedures that implement the "send"
  5.  *    command, allowing commands to be passed from interpreter
  6.  *    to interpreter.
  7.  * Status -
  8.  *    being developed
  9.  *
  10.  * Copyright 1993 Jan Newmarch, University of Canberra
  11.  * Permission to use, copy, modify, and distribute this
  12.  * software and its documentation for any purpose and without
  13.  * fee is hereby granted, provided that the above copyright
  14.  * notice appear in all copies.  The author
  15.  * makes no representations about the suitability of this
  16.  * software for any purpose.  It is provided "as is" without
  17.  * express or implied warranty.
  18.  *
  19.  * Copyright 1989-1992 Regents of the University of California
  20.  * Permission to use, copy, modify, and distribute this
  21.  * software and its documentation for any purpose and without
  22.  * fee is hereby granted, provided that the above copyright
  23.  * notice appear in all copies.  The University of California
  24.  * makes no representations about the suitability of this
  25.  * software for any purpose.  It is provided "as is" without
  26.  * express or implied warranty.
  27.  */
  28.  
  29. #ifndef lint
  30. static char rcsid[] = "$Header$";
  31. #endif
  32.  
  33. #include <stdio.h>
  34. #include <stdlib.h>
  35. #include <tcl.h>
  36. #include <X11/Intrinsic.h>
  37. #include <X11/Xatom.h>
  38. #include <X11/Shell.h>
  39.  
  40. #define TM_MAXARGS 100
  41.  
  42. /*
  43.  * This contains info that is common to all widgets
  44.  * created under one display
  45.  */
  46. typedef struct DisplayInfo {
  47.     Display    *display;
  48.     Widget    toplevel;
  49.     Widget    commWidget;
  50.     Atom     registryProperty;
  51.     Atom    commProperty;
  52. } DisplayInfo;
  53.  
  54.  
  55. /* 
  56.  * The following structure is used to keep track of the
  57.  * interpreters registered by this process.
  58.  */
  59.  
  60. typedef struct RegisteredInterp {
  61.     char *name;            /* Interpreter's name (malloc-ed). */
  62.     Tcl_Interp *interp;        /* Interpreter associated with
  63.                  * name. */
  64.     DisplayInfo *dispPtr;    /* Display info associated with name. */
  65.     struct RegisteredInterp *nextPtr;
  66.                 /* Next in list of names associated
  67.                  * with interps in this process.
  68.                  * NULL means end of list. */
  69. } RegisteredInterp;
  70.  
  71. static RegisteredInterp *registry = NULL;
  72.                 /* List of all interpreters
  73.                  * registered by this process. */
  74.  
  75. /*
  76.  * When a result is being awaited from a sent command, one of
  77.  * the following structures is present on a list of all outstanding
  78.  * sent commands.  The information in the structure is used to
  79.  * process the result when it arrives.  You're probably wondering
  80.  * how there could ever be multiple outstanding sent commands.
  81.  * This could happen if interpreters invoke each other recursively.
  82.  * It's unlikely, but possible.
  83.  */
  84.  
  85. typedef struct PendingCommand {
  86.     int serial;            /* Serial number expected in
  87.                  * result. */
  88.     char *target;        /* Name of interpreter command is
  89.                  * being sent to. */
  90.     Tcl_Interp *interp;        /* Interpreter from which the send
  91.                  * was invoked. */
  92.     int code;            /* Tcl return code for command
  93.                  * will be stored here. */
  94.     char *result;        /* String result for command (malloc'ed).
  95.                  * NULL means command still pending. */
  96.     Boolean timedOut;        /* True means timeout proc triggered
  97.                  * false means it hasn't */
  98.     struct PendingCommand *nextPtr;
  99.                 /* Next in list of all outstanding
  100.                  * commands.  NULL means end of
  101.                  * list. */
  102. } PendingCommand;
  103.  
  104. static PendingCommand *pendingCommands = NULL;
  105.                 /* List of all commands currently
  106.                  * being waited for. */
  107.  
  108. /*
  109.  * The information below is used for communication between
  110.  * processes during "send" commands.  Each process keeps a
  111.  * private window, never even mapped, with one property,
  112.  * "Comm".  When a command is sent to an interpreter, the
  113.  * command is appended to the comm property of the communication
  114.  * window associated with the interp's process.  Similarly, when a
  115.  * result is returned from a sent command, it is also appended
  116.  * to the comm property.  In each case, the property information
  117.  * is in the form of an ASCII string.  The exact syntaxes are:
  118.  *
  119.  * Command:
  120.  *    'C' space window space serial space interpName '|' command '\0'
  121.  * The 'C' character indicates that this is a command and not
  122.  * a response.  Window is the hex identifier for the comm
  123.  * window on which to append the response.  Serial is a hex
  124.  * integer containing an identifying number assigned by the
  125.  * sender;  it may be used by the sender to sort out concurrent
  126.  * responses.  InterpName is the ASCII name of the desired
  127.  * interpreter, which must not contain any vertical bar characters
  128.  * The interpreter name is delimited by a vertical bar (this
  129.  * allows the name to include blanks), and is followed by
  130.  * the command to execute.  The command is terminated by a
  131.  * NULL character.
  132.  *
  133.  * Response:
  134.  *    'R' space serial space code space result '\0'
  135.  * The 'R' character indicates that this is a response.  Serial
  136.  * gives the identifier for the command (same value as in the
  137.  * command message).  The code field is a decimal integer giving
  138.  * the Tcl return code from the command, and result is the string
  139.  * result.  The result is terminated by a NULL character.
  140.  *
  141.  * The register of interpreters is kept in a property
  142.  * "InterpRegistry" on the root window of the display.  It is
  143.  * organized as a series of zero or more concatenated strings
  144.  * (in no particular order), each of the form
  145.  *     window space name '\0'
  146.  * where "window" is the hex id of the comm. window to use to talk
  147.  * to an interpreter named "name".
  148.  */
  149.  
  150. /*
  151.  * Maximum size property that can be read at one time by
  152.  * this module:
  153.  */
  154.  
  155. #define MAX_PROP_WORDS 100000
  156.  
  157. /*
  158.  * Forward declarations for procedures defined later in this file:
  159.  */
  160.  
  161. static int    AppendErrorProc _ANSI_ARGS_((Display *display,
  162.             XErrorEvent *errorPtr));
  163. static void    AppendPropCarefully _ANSI_ARGS_((Display *display,
  164.             Window window, Atom property, char *value,
  165.             PendingCommand *pendingPtr));
  166. static void    DeleteProc _ANSI_ARGS_((ClientData clientData));
  167. static Window    LookupName _ANSI_ARGS_((DisplayInfo *dispPtr, char *name,
  168.             int delete));
  169. static void    SendEventProc _ANSI_ARGS_((Widget w, XtPointer clientData,
  170.             XEvent *eventPtr, Boolean *continue_dispatch));
  171. static int    SendInit _ANSI_ARGS_((Tcl_Interp *interp, DisplayInfo *dispPtr));
  172. static void    TimeoutProc _ANSI_ARGS_((XtPointer clientData, 
  173.             XtIntervalId *id));
  174. static int     SendCmd _ANSI_ARGS_ ((ClientData clientData,
  175.             Tcl_Interp *interp, int argc, char **argv));
  176. static int     GetInterpNames _ANSI_ARGS_ ((ClientData clientData,
  177.             Tcl_Interp *interp, int argc, char **argv));
  178.  
  179. /*
  180.  *--------------------------------------------------------------
  181.  *
  182.  * NoOpProc -
  183.  *
  184.  *    Does nothing.
  185.  *
  186.  * Results:
  187.  *    None
  188.  *
  189.  * Side effects:
  190.  *    None
  191.  *
  192.  *--------------------------------------------------------------
  193.  */
  194. static int
  195. NoOpProc(display, event)
  196.     Display *display;
  197.     XErrorEvent *event;
  198. {
  199. #   ifdef DEBUG
  200.     fprintf(stderr, "X error occurred\n");
  201. #   endif
  202. }
  203.  
  204. /*
  205.  *--------------------------------------------------------------
  206.  *
  207.  * TclXtSend_RegisterInterp --
  208.  *
  209.  *    This procedure is called to associate an ASCII name
  210.  *    with an interpreter.  Tm_InitSend must previously
  211.  *    have been called to set up communication channels
  212.  *    and specify a display.
  213.  *
  214.  * Results:
  215.  *    Zero is returned if the name was registered successfully.
  216.  *    Non-zero means the name was already in use.
  217.  *
  218.  * Side effects:
  219.  *    Registration info is saved, thereby allowing the
  220.  *    "send" command to be used later to invoke commands
  221.  *    in the interpreter.  The registration will be removed
  222.  *    automatically when the interpreter is deleted.
  223.  *
  224.  *--------------------------------------------------------------
  225.  */
  226.  
  227. int
  228. TclXtSend_RegisterInterp(interp, name, toplevel)
  229.     Tcl_Interp *interp;        /* Interpreter associated with name. */
  230.     char *name;            /* The name that will be used to
  231.                  * refer to the interpreter in later
  232.                  * "send" commands.  Must be globally
  233.                  * unique. */
  234.     Widget toplevel;        /* toplevel widget for this
  235.                  * interp;  used to identify display
  236.                  * for communication.  */
  237. {
  238. #define TCL_MAX_NAME_LENGTH 1000
  239.     char propInfo[TCL_MAX_NAME_LENGTH + 20];
  240.     register RegisteredInterp *riPtr;
  241.     Window w;
  242.     DisplayInfo *dispPtr;
  243.  
  244. #   ifdef DEBUG
  245.     fprintf(stderr, "registering interpeter %s\n", name);
  246. #   endif
  247.     if (strchr(name, '|') != NULL) {
  248.     interp->result =
  249.         "interpreter name cannot contain '|' character";
  250.     return TCL_ERROR;
  251.     }
  252.  
  253.     dispPtr = (DisplayInfo *) XtMalloc(sizeof(DisplayInfo));
  254.     dispPtr->commWidget = NULL;
  255.     dispPtr->toplevel = toplevel;
  256.     dispPtr->display = XtDisplay(toplevel);
  257.  
  258.     if (dispPtr->commWidget == NULL) {
  259.     int result;
  260.  
  261.     result = SendInit(interp, dispPtr);
  262.     if (result != TCL_OK) {
  263.         return result;
  264.     }
  265.     }
  266.  
  267.     /*
  268.      * Make sure the name is unique, and append info about it to
  269.      * the registry property.  It's important to lock the server
  270.      * here to prevent conflicting changes to the registry property.
  271.      */
  272.  
  273. #   ifndef DONT_GRAB_SERVER
  274.         XGrabServer(dispPtr->display);
  275. #   endif
  276.     w = LookupName(dispPtr, name, 0);
  277.     if (w != (Window) 0) {
  278.     Status status;
  279.     int dummyInt;
  280.     unsigned int dummyUns;
  281.     Window dummyWin;
  282.  
  283.     /*
  284.      * The name is currently registered.  See if the commWidget
  285.      * associated with the name exists.  If not, or if the commWidget
  286.      * is *our* commWidget, then just unregister the old name (this
  287.      * could happen if an application dies without cleaning up the
  288.      * registry).
  289.      */
  290.  
  291.         XSetErrorHandler(NoOpProc);
  292.     status = XGetGeometry(dispPtr->display, w, &dummyWin, &dummyInt,
  293.         &dummyInt, &dummyUns, &dummyUns, &dummyUns, &dummyUns);
  294.         XSetErrorHandler(NULL);
  295.  
  296.     if ((status != 0) && (w != XtWindow(dispPtr->commWidget))) {
  297.         Tcl_AppendResult(interp, "interpreter name \"", name,
  298.             "\" is already in use", (char *) NULL);
  299.         XUngrabServer(dispPtr->display);
  300.         XFlush(dispPtr->display);
  301.         return TCL_ERROR;
  302.     } 
  303.     (void) LookupName(dispPtr, name, 1);
  304.     }
  305.     sprintf(propInfo, "%x %.*s", XtWindow(dispPtr->commWidget),
  306.         TCL_MAX_NAME_LENGTH, name);
  307.     XChangeProperty(dispPtr->display,
  308.         RootWindow(dispPtr->display, 0),
  309.         dispPtr->registryProperty, XA_STRING, 8, PropModeAppend,
  310.         (unsigned char *) propInfo, strlen(propInfo)+1);
  311.     XUngrabServer(dispPtr->display);
  312.     XFlush(dispPtr->display);
  313.  
  314.     /*
  315.      * Add an entry in the local registry of names owned by this
  316.      * process.
  317.      */
  318.  
  319.     riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
  320.     riPtr->name = (char *) ckalloc((unsigned) (strlen(name) + 1));
  321.     strcpy(riPtr->name, name);
  322.     riPtr->interp = interp;
  323.     riPtr->dispPtr = dispPtr;
  324.     riPtr->nextPtr = registry;
  325.     registry = riPtr;
  326.  
  327.     /*
  328.      * Add the "send" command to this interpreter, and arrange for
  329.      * us to be notified when the interpreter is deleted (actually,
  330.      * when the "send" command is deleted).
  331.      */
  332.  
  333.     Tcl_CreateCommand(interp, "send", SendCmd, (ClientData) riPtr,
  334.         DeleteProc);
  335.     Tcl_CreateCommand(interp, "interps", GetInterpNames,
  336.         (ClientData) dispPtr, NULL);
  337.  
  338. #   ifdef DEBUG
  339.     fprintf(stderr, "Registered interpreter successfully\n");
  340. #   endif
  341.  
  342.     return TCL_OK;
  343. }
  344.  
  345. static void
  346. SendRestrictEvents(app, w, pending)
  347.     XtAppContext app;
  348.     Widget w;
  349.     PendingCommand *pending;
  350. {
  351.     XEvent event;
  352.  
  353. #   ifdef DEBUG
  354.     fprintf(stderr, "Restricting events\n");
  355. #   endif
  356.  
  357. #   ifndef DONT_GRAB_SERVER
  358.         XtAddGrab(w, False, False);
  359. #   endif
  360.     while (pending->result == NULL) {
  361.     XtAppNextEvent(app, &event);
  362.     XtDispatchEvent(&event);
  363.     }
  364.     XtRemoveGrab(w);
  365.  
  366. #   ifdef DEBUG
  367.     fprintf(stderr, "Finished restricting events\n");
  368. #   endif
  369. }
  370. /*
  371.  *--------------------------------------------------------------
  372.  *
  373.  * SendCmd --
  374.  *
  375.  *    This procedure is invoked to process the "send" Tcl command.
  376.  *    See the user documentation for details on what it does.
  377.  *
  378.  * Results:
  379.  *    A standard Tcl result.
  380.  *
  381.  * Side effects:
  382.  *    See the user documentation.
  383.  *
  384.  *--------------------------------------------------------------
  385.  */
  386.  
  387. static int
  388. SendCmd(clientData, interp, argc, argv)
  389.     ClientData clientData;        /* Information about sender (only
  390.                      * dispPtr field is used). */
  391.     Tcl_Interp *interp;            /* Current interpreter. */
  392.     int argc;                /* Number of arguments. */
  393.     char **argv;            /* Argument strings. */
  394. {
  395.     RegisteredInterp *senderRiPtr = (RegisteredInterp *) clientData;
  396.     Window w;
  397. #define STATIC_PROP_SPACE 100
  398.     char *property, staticSpace[STATIC_PROP_SPACE];
  399.     int length;
  400.     static int serial = 0;    /* Running count of sent commands.
  401.                  * Used to give each command a
  402.                  * different serial number. */
  403.     PendingCommand pending;
  404.     XtIntervalId timer;
  405.     XtAppContext app;
  406.     register RegisteredInterp *riPtr;
  407.     char *cmd;
  408.     int result;
  409.     Bool (*prevRestrictProc)();
  410.     char *prevArg;
  411.     DisplayInfo *dispPtr = senderRiPtr->dispPtr;
  412.  
  413. #   ifdef DEBUG
  414.     fprintf(stderr, "Sending command\n");
  415. #   endif
  416.  
  417.     if (dispPtr->commWidget == NULL) {
  418.     result = SendInit(interp, dispPtr);
  419.     if (result != TCL_OK) {
  420.         return result;
  421.     }
  422.     }
  423.  
  424.     if (argc < 3) {
  425.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  426.         " interpName arg ?arg ...?\"", (char *) NULL);
  427.     return TCL_ERROR;
  428.     }
  429.     if (argc == 3) {
  430.     cmd = argv[2];
  431.     } else {
  432.     cmd = Tcl_Concat(argc-2, argv+2);
  433.     }
  434. #   ifdef DEBUG
  435.     fprintf(stderr, "  command is: %s\n", cmd);
  436. #   endif
  437.  
  438.     /*
  439.      * See if the target interpreter is local.  If so, execute
  440.      * the command directly without going through the X server.
  441.      * The only tricky thing is passing the result from the target
  442.      * interpreter to the invoking interpreter.  Watch out:  they
  443.      * could be the same!
  444.      */
  445.  
  446.     for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) {
  447.     if (strcmp(riPtr->name, argv[1]) != 0) {
  448.         continue;
  449.     }
  450.     if (interp == riPtr->interp) {
  451.         result = Tcl_GlobalEval(interp, cmd);
  452.     } else {
  453.         result = Tcl_GlobalEval(riPtr->interp, cmd);
  454.         interp->result = riPtr->interp->result;
  455.         interp->freeProc = riPtr->interp->freeProc;
  456.         riPtr->interp->freeProc = 0;
  457.         Tcl_ResetResult(riPtr->interp);
  458.     }
  459.     if (cmd != argv[2]) {
  460.         ckfree(cmd);
  461.     }
  462.     return result;
  463.     }
  464.  
  465.     /*
  466.      * Bind the interpreter name to a communication window.
  467.      */
  468.  
  469.     w = LookupName(dispPtr, argv[1], 0);
  470.     if (w == 0) {
  471.     Tcl_AppendResult(interp, "no registered interpeter named \"",
  472.         argv[1], "\"", (char *) NULL);
  473.     if (cmd != argv[2]) {
  474.         ckfree(cmd);
  475.     }
  476.     return TCL_ERROR;
  477.     }
  478.  
  479.     /*
  480.      * Register the fact that we're waiting for a command to
  481.      * complete (this is needed by SendEventProc and by
  482.      * AppendErrorProc to pass back the command's results).
  483.      */
  484.  
  485.     serial++;
  486.     pending.serial = serial;
  487.     pending.target = argv[1];
  488.     pending.interp = interp;
  489.     pending.result = NULL;
  490.     pending.timedOut = FALSE;
  491.     pending.nextPtr = pendingCommands;
  492.     pendingCommands = &pending;
  493.  
  494.     /*
  495.      * Send the command to target interpreter by appending it to the
  496.      * comm window in the communication window.
  497.      */
  498.  
  499.     length = strlen(argv[1]) + strlen(cmd) + 30;
  500.     if (length <= STATIC_PROP_SPACE) {
  501.     property = staticSpace;
  502.     } else {
  503.     property = (char *) ckalloc((unsigned) length);
  504.     }
  505.     sprintf(property, "C %x %x %s|%s",
  506.         XtWindow(dispPtr->commWidget), serial, argv[1], cmd);
  507.     (void) AppendPropCarefully(dispPtr->display, w, dispPtr->commProperty,
  508.         property, &pending);
  509.     if (length > STATIC_PROP_SPACE) {
  510.     ckfree(property);
  511.     }
  512.     if (cmd != argv[2]) {
  513.     ckfree(cmd);
  514.     }
  515. #   ifdef DEBUG
  516.     fprintf(stderr, "Command sent, awaiting rsponse\n");
  517. #   endif
  518.  
  519.     /*
  520.      * Enter a loop processing X events until the result comes
  521.      * in.  If no response is received within a few seconds,
  522.      * then timeout.  While waiting for a result, look only at
  523.      * send-related events (otherwise it would be possible for
  524.      * additional input events, such as mouse motion, to cause
  525.      * other sends, leading eventually to such a large number
  526.      * of nested Tcl_Eval calls that the Tcl interpreter panics).
  527.      */
  528.  
  529.     app = XtWidgetToApplicationContext(dispPtr->commWidget);
  530.     timer = XtAppAddTimeOut(app, 5000, TimeoutProc, (XtPointer) &pending);
  531.  
  532.     SendRestrictEvents(app, dispPtr->commWidget, &pending);
  533.  
  534.     if ( ! pending.timedOut) {
  535.     XtRemoveTimeOut(timer);
  536.     }
  537.  
  538.     /*
  539.      * Unregister the information about the pending command
  540.      * and return the result.
  541.      */
  542.  
  543.     if (pendingCommands == &pending) {
  544.     pendingCommands = pending.nextPtr;
  545.     } else {
  546.     PendingCommand *pcPtr;
  547.  
  548.     for (pcPtr = pendingCommands; pcPtr != NULL;
  549.         pcPtr = pcPtr->nextPtr) {
  550.         if (pcPtr->nextPtr == &pending) {
  551.         pcPtr->nextPtr = pending.nextPtr;
  552.         break;
  553.         }
  554.     }
  555.     }
  556. #   ifdef DEBUG
  557.     fprintf(stderr, "Send over, result: %s, code: %d\n",
  558.         pending.result, pending.code);
  559. #   endif
  560.  
  561.     Tcl_SetResult(interp, pending.result, TCL_DYNAMIC);
  562.     return pending.code;
  563. }
  564. /*
  565.  *----------------------------------------------------------------------
  566.  *
  567.  * GetInterpNames --
  568.  *
  569.  *    This procedure is invoked to fetch a list of all the
  570.  *    interpreter names currently registered for the display
  571.  *    of a particular window.
  572.  *
  573.  * Results:
  574.  *    A standard Tcl return value.  Interp->result will be set
  575.  *    to hold a list of all the interpreter names defined for
  576.  *    tkwin's display.  If an error occurs, then TCL_ERROR
  577.  *    is returned and interp->result will hold an error message.
  578.  *
  579.  * Side effects:
  580.  *    None.
  581.  *
  582.  *----------------------------------------------------------------------
  583.  */
  584.  
  585. static int
  586. GetInterpNames(clientData, interp, argc, argv)
  587.     ClientData clientData;
  588.     Tcl_Interp *interp;        /* Interpreter for returning a result. */
  589.     int argc;
  590.     char **argv;
  591. {
  592.     DisplayInfo *dispPtr = (DisplayInfo *) clientData;
  593.     char *regProp, *separator, *name;
  594.     register char *p;
  595.     int result, actualFormat;
  596.     unsigned long numItems, bytesAfter;
  597.     Atom actualType;
  598.  
  599.     /*
  600.      * Read the registry property.
  601.      */
  602.  
  603.     regProp = NULL;
  604.     result = XGetWindowProperty(dispPtr->display,
  605.         RootWindow(dispPtr->display, 0),
  606.         dispPtr->registryProperty, 0, MAX_PROP_WORDS,
  607.         False, XA_STRING, &actualType, &actualFormat,
  608.         &numItems, &bytesAfter, (unsigned char **) ®Prop);
  609.  
  610.     if (actualType == None) {
  611.     sprintf(interp->result, "couldn't read intepreter registry property");
  612.     return TCL_ERROR;
  613.     }
  614.  
  615.     /*
  616.      * If the property is improperly formed, then delete it.
  617.      */
  618.  
  619.     if ((result != Success) || (actualFormat != 8)
  620.         || (actualType != XA_STRING)) {
  621.     if (regProp != NULL) {
  622.         XFree(regProp);
  623.     }
  624.     sprintf(interp->result, "intepreter registry property is badly formed");
  625.     return TCL_ERROR;
  626.     }
  627.  
  628.     /*
  629.      * Scan all of the names out of the property.
  630.      */
  631.  
  632.     separator = "";
  633.     for (p = regProp; (p-regProp) < numItems; p++) {
  634.     name = p;
  635.     while ((*p != 0) && (!isspace(*p))) {
  636.         p++;
  637.     }
  638.     if (*p != 0) {
  639.         name = p+1;
  640.         name = Tcl_Merge(1, &name);
  641.         Tcl_AppendResult(interp, separator, name, (char *) NULL);
  642.         while (*p != 0) {
  643.         p++;
  644.         }
  645.         separator = " ";
  646.     }
  647.     }
  648.     XFree(regProp);
  649.     return TCL_OK;
  650. }
  651. /*
  652.  *--------------------------------------------------------------
  653.  *
  654.  * SendInit --
  655.  *
  656.  *    This procedure is called to initialize the
  657.  *    communication channels for sending commands and
  658.  *    receiving results.
  659.  *
  660.  * Results:
  661.  *    The result is a standard Tcl return value, which is
  662.  *    normally TCL_OK.  If an error occurs then an error
  663.  *    message is left in interp->result and TCL_ERROR is
  664.  *    returned.
  665.  *
  666.  * Side effects:
  667.  *    Sets up various data structures and windows.
  668.  *
  669.  *--------------------------------------------------------------
  670.  */
  671.  
  672. static int
  673. SendInit(interp, dispPtr)
  674.     Tcl_Interp *interp;        /* Interpreter to use for error
  675.                  * reporting. */
  676.     register DisplayInfo *dispPtr;/* Display to initialize. */
  677.  
  678. {
  679.     Widget parent;
  680.  
  681.     /*
  682.      * Get atoms used as property names.
  683.      */
  684.  
  685.     dispPtr->commProperty = XInternAtom(dispPtr->display,
  686.         "Comm", False);
  687.     dispPtr->registryProperty = XInternAtom(dispPtr->display,
  688.         "InterpRegistry", False);
  689.  
  690.     /*
  691.      * Create the window used for communication, and set up an
  692.      * event handler for it, unless it already exists.
  693.      */
  694.  
  695.     parent = dispPtr->toplevel;
  696.     if ((dispPtr->commWidget = XtNameToWidget(parent, "_comm")) != NULL)
  697.     return TCL_OK;
  698.  
  699.     dispPtr->commWidget = XtVaCreateWidget("_comm",
  700.                     transientShellWidgetClass,
  701.                     parent,
  702.                     XtNgeometry, "10x10", 
  703.                     XtNoverrideRedirect, TRUE,
  704.                     NULL);
  705.     if (dispPtr->commWidget == NULL) {
  706.     return TCL_ERROR;
  707.     }
  708.     XtRealizeWidget(dispPtr->commWidget);
  709.     XtAddEventHandler(dispPtr->commWidget, PropertyChangeMask,
  710.             FALSE, SendEventProc, dispPtr);
  711.  
  712.     return TCL_OK;
  713. }
  714. /*
  715.  *--------------------------------------------------------------
  716.  *
  717.  * LookupName --
  718.  *
  719.  *    Given an interpreter name, see if the name exists in
  720.  *    the interpreter registry for a particular display.
  721.  *
  722.  * Results:
  723.  *    If the given name is registered, return the ID of
  724.  *    the window associated with the name.  If the name
  725.  *    isn't registered, then return 0.
  726.  *
  727.  * Side effects:
  728.  *    If the registry property is improperly formed, then
  729.  *    it is deleted.  If "delete" is non-zero, then if the
  730.  *    named interpreter is found it is removed from the
  731.  *    registry property.
  732.  *
  733.  *--------------------------------------------------------------
  734.  */
  735.  
  736. static Window
  737. LookupName(dispPtr, name, delete)
  738.     register DisplayInfo *dispPtr;
  739.             /* Display whose registry to check. */
  740.     char *name;        /* Name of an interpreter. */
  741.     int delete;        /* If non-zero, delete info about name. */
  742. {
  743.     char *regProp, *entry;
  744.     register char *p;
  745.     int result, actualFormat;
  746.     unsigned long numItems, bytesAfter;
  747.     Atom actualType;
  748.     Window returnValue;
  749.  
  750.     /*
  751.      * Read the registry property.
  752.      */
  753.  
  754.     regProp = NULL;
  755.     result = XGetWindowProperty(dispPtr->display,
  756.         RootWindow(dispPtr->display, 0),
  757.         dispPtr->registryProperty, 0, MAX_PROP_WORDS,
  758.         False, XA_STRING, &actualType, &actualFormat,
  759.         &numItems, &bytesAfter, (unsigned char **) ®Prop);
  760.  
  761.     if (actualType == None) {
  762.     return 0;
  763.     }
  764.  
  765.     /*
  766.      * If the property is improperly formed, then delete it.
  767.      */
  768.  
  769.     if ((result != Success) || (actualFormat != 8)
  770.         || (actualType != XA_STRING)) {
  771.     if (regProp != NULL) {
  772.         XFree(regProp);
  773.     }
  774.     XDeleteProperty(dispPtr->display,
  775.         RootWindow(dispPtr->display, 0),
  776.         dispPtr->registryProperty);
  777.     return 0;
  778.     }
  779.  
  780.     /*
  781.      * Scan the property for the desired name.
  782.      */
  783.  
  784.     returnValue = (Window) 0;
  785.     entry = NULL;    /* Not needed, but eliminates compiler warning. */
  786.     for (p = regProp; (p-regProp) < numItems; ) {
  787.     entry = p;
  788.     while ((*p != 0) && (!isspace(*p))) {
  789.         p++;
  790.     }
  791.     if ((*p != 0) && (strcmp(name, p+1) == 0)) {
  792.         sscanf(entry, "%x", &returnValue);
  793.         break;
  794.     }
  795.     while (*p != 0) {
  796.         p++;
  797.     }
  798.     p++;
  799.     }
  800.  
  801.     /*
  802.      * Delete the property, if that is desired (copy down the
  803.      * remainder of the registry property to overlay the deleted
  804.      * info, then rewrite the property).
  805.      */
  806.  
  807.     if ((delete) && (returnValue != 0)) {
  808.     int count;
  809.  
  810.     while (*p != 0) {
  811.         p++;
  812.     }
  813.     p++;
  814.     count = numItems - (p-regProp);
  815.     if (count > 0) {
  816.         memcpy((VOID *) entry, (VOID *) p, count);
  817.     }
  818.     XChangeProperty(dispPtr->display,
  819.         RootWindow(dispPtr->display, 0),
  820.         dispPtr->registryProperty, XA_STRING, 8,
  821.         PropModeReplace, (unsigned char *) regProp,
  822.         (int) (numItems - (p-entry)));
  823.     XSync(dispPtr->display, False);
  824.     }
  825.  
  826.     XFree(regProp);
  827.     return returnValue;
  828. }
  829. /*
  830.  *--------------------------------------------------------------
  831.  *
  832.  * SendEventProc --
  833.  *
  834.  *    This procedure is invoked automatically by the toolkit
  835.  *    event manager when a property changes on the communication
  836.  *    window.  This procedure reads the property and handles
  837.  *    command requests and responses.
  838.  *
  839.  * Results:
  840.  *    None.
  841.  *
  842.  * Side effects:
  843.  *    If there are command requests in the property, they
  844.  *    are executed.  If there are responses in the property,
  845.  *    their information is saved for the (ostensibly waiting)
  846.  *    "send" commands. The property is deleted.
  847.  *
  848.  *--------------------------------------------------------------
  849.  */
  850.  
  851. static void
  852. SendEventProc(w, clientData, eventPtr, continue_dispatch)
  853.     Widget w;
  854.     XtPointer clientData;    /* Display information. */    
  855.     XEvent *eventPtr;        /* Information about event. */
  856.     Boolean *continue_dispatch;
  857. {
  858.     DisplayInfo *dispPtr = (DisplayInfo *) clientData;
  859.     char *propInfo;
  860.     register char *p;
  861.     int result, actualFormat;
  862.     unsigned long numItems, bytesAfter;
  863.     Atom actualType;
  864.  
  865. #   ifdef DEBUG
  866.     fprintf(stderr, "Send arriving\n");
  867. #   endif
  868.     if ((eventPtr->xproperty.atom != dispPtr->commProperty)
  869.         || (eventPtr->xproperty.state != PropertyNewValue)) {
  870.     return;
  871.     }
  872.  
  873.     /*
  874.      * Read the comm property and delete it.
  875.      */
  876.  
  877.     propInfo = NULL;
  878.     XSetErrorHandler(NoOpProc);
  879.     result = XGetWindowProperty(dispPtr->display,
  880.         XtWindow(dispPtr->commWidget),
  881.         dispPtr->commProperty, 0, MAX_PROP_WORDS, True,
  882.         XA_STRING, &actualType, &actualFormat,
  883.         &numItems, &bytesAfter, (unsigned char **) &propInfo);
  884.     XSetErrorHandler(NULL);
  885.  
  886.     /*
  887.      * If the property doesn't exist or is improperly formed
  888.      * then ignore it.
  889.      */
  890.  
  891.     if ((result != Success) || (actualType != XA_STRING)
  892.         || (actualFormat != 8)) {
  893.     if (propInfo != NULL) {
  894.         XFree(propInfo);
  895.     }
  896. #    ifdef DEBUG
  897.         fprintf(stderr, "bad property format?\n");
  898. #    endif
  899.     return;
  900.     }
  901.  
  902.     /*
  903.      * The property is divided into records separated by null
  904.      * characters.  Each record represents one command request
  905.      * or response.  Scan through the property one record at a
  906.      * time.
  907.      */
  908.  
  909. #   ifdef DEBUG
  910.     fprintf(stderr, "Property is: %s\n", propInfo);
  911. #   endif
  912.     for (p = propInfo; (p-propInfo) < numItems; ) {
  913.     if (*p == 'C') {
  914.         Window window;
  915.         int serial, resultSize;
  916.         char *resultString, *interpName, *returnProp, *end;
  917.         register RegisteredInterp *riPtr;
  918.         char errorMsg[100];
  919. #define STATIC_RESULT_SPACE 100
  920.         char staticSpace[STATIC_RESULT_SPACE];
  921.  
  922.         /*
  923.          *-----------------------------------------------------
  924.          * This is an incoming command sent by another window.
  925.          * Parse the fields of the command string.  If the command
  926.          * string isn't properly formed, send back an error message
  927.          * if there's enough well-formed information to generate
  928.          * a proper reply;  otherwise just ignore the message.
  929.          *-----------------------------------------------------
  930.          */
  931.  
  932.         p++;
  933.         window = (Window) strtol(p, &end, 16);
  934.         if (end == p) {
  935.         goto nextRecord;
  936.         }
  937.         p = end;
  938.         if (*p != ' ') {
  939.         goto nextRecord;
  940.         }
  941.         p++;
  942.         serial = strtol(p, &end, 16);
  943.         if (end == p) {
  944.         goto nextRecord;
  945.         }
  946.         p = end;
  947.         if (*p != ' ') {
  948.         goto nextRecord;
  949.         }
  950.         p++;
  951.         interpName = p;
  952.         while ((*p != 0) && (*p != '|')) {
  953.         p++;
  954.         }
  955.         if (*p != '|') {
  956.         result = TCL_ERROR;
  957.         resultString = "bad property format for sent command";
  958.         goto returnResult;
  959.         }
  960.         *p = 0;
  961.         p++;
  962.  
  963.         /*
  964.          * Locate the interpreter for the command, then
  965.          * execute the command.
  966.          */
  967.  
  968.         for (riPtr = registry; ; riPtr = riPtr->nextPtr) {
  969.         if (riPtr == NULL) {
  970.             result = TCL_ERROR;
  971.             sprintf(errorMsg,
  972.                 "receiver never heard of interpreter \"%.40s\"",
  973.                 interpName);
  974.             resultString = errorMsg;
  975.             goto returnResult;
  976.         }
  977.         if (strcmp(riPtr->name, interpName) == 0) {
  978.             break;
  979.         }
  980.         }
  981. #        ifdef DEBUG
  982.         fprintf(stderr, "Executing sent command %s\n", p);
  983. #        endif
  984.         result = Tcl_GlobalEval(riPtr->interp, p);
  985.         resultString = riPtr->interp->result;
  986.  
  987.         /*
  988.          * Return the result to the sender.
  989.          */
  990.  
  991.         returnResult:
  992.         resultSize = strlen(resultString) + 30;
  993.         if (resultSize <= STATIC_RESULT_SPACE) {
  994.         returnProp = staticSpace;
  995.         } else {
  996.         returnProp = (char *) ckalloc((unsigned) resultSize);
  997.         }
  998.         sprintf(returnProp, "R %x %d %s", serial, result,
  999.             resultString);
  1000. #        ifdef DEBUG
  1001.         fprintf(stderr, "returning result: %s\n", returnProp);
  1002. #        endif
  1003.         (void) AppendPropCarefully(dispPtr->display, window,
  1004.             dispPtr->commProperty, returnProp,
  1005.             (PendingCommand *) NULL);
  1006.         if (returnProp != staticSpace) {
  1007.         ckfree(returnProp);
  1008.         }
  1009.     } else if (*p == 'R') {
  1010.         int serial, code;
  1011.         char *end;
  1012.         register PendingCommand *pcPtr;
  1013.  
  1014.         /*
  1015.          *-----------------------------------------------------
  1016.          * This record in the property is a result being
  1017.          * returned for a command sent from here.  First
  1018.          * parse the fields.
  1019.          *-----------------------------------------------------
  1020.          */
  1021.  
  1022. #        ifdef DEBUG
  1023.         fprintf(stderr, "Result being returned\n");
  1024. #        endif
  1025.         p++;
  1026.         serial = strtol(p, &end, 16);
  1027.         if (end == p) {
  1028.         goto nextRecord;
  1029.         }
  1030.         p = end;
  1031.         if (*p != ' ') {
  1032.         goto nextRecord;
  1033.         }
  1034.         p++;
  1035.         code = strtol(p, &end, 10);
  1036.         if (end == p) {
  1037.         goto nextRecord;
  1038.         }
  1039.         p = end;
  1040.         if (*p != ' ') {
  1041.         goto nextRecord;
  1042.         }
  1043.         p++;
  1044.  
  1045.         /*
  1046.          * Give the result information to anyone who's
  1047.          * waiting for it.
  1048.          */
  1049.  
  1050.         for (pcPtr = pendingCommands; pcPtr != NULL;
  1051.             pcPtr = pcPtr->nextPtr) {
  1052.         if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) {
  1053.             continue;
  1054.         }
  1055.         pcPtr->code = code;
  1056.         pcPtr->result = ckalloc((unsigned) (strlen(p) + 1));
  1057.         strcpy(pcPtr->result, p);
  1058.         break;
  1059.         }
  1060.     }
  1061.  
  1062.     nextRecord:
  1063.     while (*p != 0) {
  1064.         p++;
  1065.     }
  1066.     p++;
  1067.     }
  1068.     XFree(propInfo);
  1069. #   ifdef DEBUG
  1070.     fprintf(stderr, "Send handled\n");
  1071. #   endif
  1072. }
  1073. static PendingCommand *globalPendingPtr; /* hack for poor error handling */
  1074. /*
  1075.  *--------------------------------------------------------------
  1076.  *
  1077.  * AppendPropCarefully --
  1078.  *
  1079.  *    Append a given property to a given window, but set up
  1080.  *    an X error handler so that if the append fails this
  1081.  *    procedure can return an error code rather than having
  1082.  *    Xlib panic.
  1083.  *
  1084.  * Results:
  1085.  *    None.
  1086.  *
  1087.  * Side effects:
  1088.  *    The given property on the given window is appended to.
  1089.  *    If this operation fails and if pendingPtr is non-NULL,
  1090.  *    then the pending operation is marked as complete with
  1091.  *    an error.
  1092.  *
  1093.  *--------------------------------------------------------------
  1094.  */
  1095.  
  1096. static void
  1097. AppendPropCarefully(display, window, property, value, pendingPtr)
  1098.     Display *display;        /* Display on which to operate. */
  1099.     Window window;        /* Window whose property is to
  1100.                  * be modified. */
  1101.     Atom property;        /* Name of property. */
  1102.     char *value;        /* Characters (null-terminated) to
  1103.                  * append to property. */
  1104.     PendingCommand *pendingPtr;    /* Pending command to mark complete
  1105.                  * if an error occurs during the
  1106.                  * property op.  NULL means just
  1107.                  * ignore the error. */
  1108. {
  1109.     /* I don't have a full error mechanism going that forms lists
  1110.      * with client_data like Tk does, so I'll indulge in a grotty
  1111.      * piece of code: set a global to hold the PendingCommand and
  1112.      * XSync to force execution of the error handler before anything
  1113.      * else happens. One day, clean this up
  1114.      */
  1115.     XSetErrorHandler(AppendErrorProc);
  1116.     globalPendingPtr = pendingPtr;
  1117.     XChangeProperty(display, window, property, XA_STRING, 8,
  1118.         PropModeAppend, (unsigned char *) value, strlen(value)+1);
  1119.     XSync(display, False);
  1120.     XSetErrorHandler(NULL);
  1121. }
  1122.  
  1123. /*
  1124.  * The procedure below is invoked if an error occurs during
  1125.  * the XChangeProperty operation above.
  1126.  */
  1127.  
  1128.     /* ARGSUSED */
  1129. static int
  1130. AppendErrorProc(display, errorPtr)
  1131.     Display *display;
  1132.     XErrorEvent *errorPtr;    /* Information about error. */
  1133. {
  1134.     PendingCommand *pendingPtr = globalPendingPtr;
  1135.     register PendingCommand *pcPtr;
  1136.  
  1137.     if (pendingPtr == NULL) {
  1138.     return 0;
  1139.     }
  1140.  
  1141.     /*
  1142.      * Make sure this command is still pending.
  1143.      */
  1144.  
  1145.     for (pcPtr = pendingCommands; pcPtr != NULL;
  1146.         pcPtr = pcPtr->nextPtr) {
  1147.     if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) {
  1148.         pcPtr->result = ckalloc((unsigned) (strlen(pcPtr->target) + 50));
  1149.         sprintf(pcPtr->result,
  1150.             "send to \"%s\" failed (no communication window)",
  1151.             pcPtr->target);
  1152.         pcPtr->code = TCL_ERROR;
  1153.         break;
  1154.     }
  1155.     }
  1156.     return 0;
  1157. }
  1158. /*
  1159.  *--------------------------------------------------------------
  1160.  *
  1161.  * TimeoutProc --
  1162.  *
  1163.  *    This procedure is invoked when too much time has elapsed
  1164.  *    during the processing of a sent command.
  1165.  *
  1166.  * Results:
  1167.  *    None.
  1168.  *
  1169.  * Side effects:
  1170.  *    Mark the pending command as complete, with an error
  1171.  *    message signalling the timeout.
  1172.  *
  1173.  *--------------------------------------------------------------
  1174.  */
  1175.  
  1176. static void
  1177. TimeoutProc(clientData, timer)
  1178.     XtPointer clientData;    /* Information about command that
  1179.                  * has been sent but not yet
  1180.                  * responded to. */
  1181.     XtIntervalId *timer;
  1182. {
  1183.     PendingCommand *pcPtr = (PendingCommand *) clientData;
  1184.     register PendingCommand *pcPtr2;
  1185.  
  1186. #   ifdef DEBUG
  1187.     fprintf(stderr, "Timer gone off\n");
  1188. #   endif
  1189.  
  1190.     /*
  1191.      * Make sure that the command is still in the pending list
  1192.      * and that it hasn't already completed.  Then register the
  1193.      * error.
  1194.      */
  1195.  
  1196.     for (pcPtr2 = pendingCommands; pcPtr2 != NULL;
  1197.         pcPtr2 = pcPtr2->nextPtr) {
  1198.     static char msg[] = "remote interpreter did not respond";
  1199.     if ((pcPtr2 != pcPtr) || (pcPtr2->result != NULL)) {
  1200.         continue;
  1201.     }
  1202.     pcPtr2->code = TCL_ERROR;
  1203.     pcPtr2->result = ckalloc((unsigned) (sizeof(msg) + 1));
  1204.     strcpy(pcPtr2->result, msg);
  1205.     pcPtr2->timedOut = TRUE;
  1206.     return;
  1207.     }
  1208. }
  1209. /*
  1210.  *--------------------------------------------------------------
  1211.  *
  1212.  * DeleteProc --
  1213.  *
  1214.  *    This procedure is invoked by Tcl when a registered
  1215.  *    interpreter is about to be deleted.  It unregisters
  1216.  *    the interpreter.
  1217.  *
  1218.  * Results:
  1219.  *    None.
  1220.  *
  1221.  * Side effects:
  1222.  *    The interpreter given by riPtr is unregistered.
  1223.  *
  1224.  *--------------------------------------------------------------
  1225.  */
  1226.  
  1227. static void
  1228. DeleteProc(clientData)
  1229.     ClientData clientData;    /* Info about registration, passed
  1230.                  * as ClientData. */
  1231. {
  1232.     RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
  1233.     register RegisteredInterp *riPtr2;
  1234.  
  1235. #   ifndef DONT_GRAB_SERVER
  1236.         XGrabServer(riPtr->dispPtr->display);
  1237. #   endif
  1238.     (void) LookupName(riPtr->dispPtr, riPtr->name, 1);
  1239.     XUngrabServer(riPtr->dispPtr->display);
  1240.     XFlush(riPtr->dispPtr->display);
  1241.     if (registry == riPtr) {
  1242.     registry = riPtr->nextPtr;
  1243.     } else {
  1244.     for (riPtr2 = registry; riPtr2 != NULL;
  1245.         riPtr2 = riPtr2->nextPtr) {
  1246.         if (riPtr2->nextPtr == riPtr) {
  1247.         riPtr2->nextPtr = riPtr->nextPtr;
  1248.         break;
  1249.         }
  1250.     }
  1251.     }
  1252.     ckfree((char *) riPtr->name);
  1253.     ckfree((char *) riPtr);
  1254. }
  1255.